home *** CD-ROM | disk | FTP | other *** search
/ Software Vault: The Gold Collection / Software Vault - The Gold Collection (American Databankers) (1993).ISO / cdr48 / pcl4p35.zip / TERM_IO.PAS < prev    next >
Pascal/Delphi Source File  |  1993-03-09  |  5KB  |  205 lines
  1. (* TERM_IO.PAS *)
  2.  
  3. {  $DEFINE DEBUG}
  4. {$I DEFINES.PAS}
  5.  
  6. (*********************************************)
  7. (*                                           *)
  8. (*  Used for I/O by TERM.PAS                 *)
  9. (*                                           *)
  10. (*  This program is donated to the Public    *)
  11. (*  Domain by MarshallSoft Computing, Inc.   *)
  12. (*  It is provided as an example of the use  *)
  13. (*  of the Personal Communications Library.  *)
  14. (*                                           *)
  15. (*********************************************)
  16.  
  17.  
  18. unit term_IO;
  19.  
  20. interface
  21.  
  22. type
  23.   String40 = String[40];
  24.   String20 = String[20];
  25.  
  26. Procedure WriteMsg(MsgString:String40; StartCol:Byte);
  27. Procedure ReadMsg(VAR MsgString:String20; StartCol, MaxLength:Byte);
  28. Procedure PutChar(Port:Integer; c:Byte);
  29. Function  GetChar(Port:Integer; Timeout:Integer):Integer;
  30. Procedure SayError(Code:Integer;Message:String40);
  31. Procedure TxCAN(Port:Integer);
  32.  
  33. implementation
  34.  
  35. uses PCL4P,HEX_IO,CRT;
  36.  
  37. const
  38.   CR  : Byte = $0d;
  39.   ESC : Byte = $1B;
  40.   BS  : Byte = $08;
  41.   BLK : Byte = $20;
  42.   CAN : Byte = $18;
  43.  
  44.  
  45. Procedure WriteMsg(MsgString:String40; StartCol:Byte);
  46. var
  47.   i:Integer;
  48.   Row:Byte;
  49.   Col:Byte;
  50. begin
  51.   Col := WhereX;
  52.   Row := WhereY;
  53.   (* goto display window *)
  54.   Window(1,25,80,25);
  55.   HighVideo;
  56.   GotoXY(StartCol,1);
  57.   Write(MsgString);
  58.   for i := Length(MsgString)+1 to 39 do Write(' ');
  59.   (* back to main window *)
  60.   Window(1,1,80,24);
  61.   LowVideo;
  62.   GotoXY(Col,Row);
  63. end;
  64.  
  65.  
  66. Procedure ReadMsg(VAR MsgString:String20; StartCol, MaxLength:Byte);
  67. Label 999;
  68. var
  69.   Row:Byte;
  70.   Col:Byte;
  71.   i  :Byte;
  72.   c  :Char;
  73. begin
  74.   Row := WhereY;
  75.   Col := WhereX;
  76.   (* goto  display window *)
  77.   Window(1,25,80,25);
  78.   HighVideo;
  79.   (* input text from user *)
  80.   i := 0;
  81.   while true do
  82.      begin
  83.        GotoXY(StartCol+i,1);
  84.        c := ReadKey;
  85.        case ord(c) of
  86.          $0D : goto 999;
  87.          $1B : (* Escape *)
  88.            begin
  89.              (* return empty string *)
  90.              i := 0;
  91.              goto 999;
  92.            end;
  93.          $08 : (* backspace *)
  94.            begin
  95.              (* back up if can *)
  96.              if i > 0 then
  97.                begin
  98.                  (* adjust buffer *)
  99.                  i := i - 1;
  100.                  (* write blank at cursor *)
  101.                  GotoXY(StartCol+i,1);
  102.                  write(' ');
  103.                  GotoXY(StartCol+i,1)
  104.                end
  105.            end
  106.        else (* not one of above special chars *)
  107.          begin
  108.            (* save character *)
  109.            i := i + 1;
  110.            MsgString[i] := c;
  111.            (* display on bottom line *)
  112.            Write(c);
  113.            (* done ? *)
  114.            if i = MaxLength then goto 999;
  115.          end
  116.        end (* case *)
  117.      end; (* end while *)
  118. 999:(* set length *)
  119.   MsgString[0] := chr(i);
  120.   (* back to main window *)
  121.   Window(1,1,80,24);
  122.   LowVideo;
  123.   GotoXY(Col,Row);
  124. end;
  125.  
  126. (*** Send character over serial line ***)
  127.  
  128. Procedure PutChar(Port:Integer; C:Byte);
  129. var
  130.   Code:Integer;
  131. begin
  132.   Code := SioPutc(Port,chr(C));
  133.   if Code < 0 then
  134.      begin
  135.        writeln('COM',1+Port,' error');
  136.        Code := SioError(Code);
  137.        Code := SioDone(Port);
  138.        Halt;
  139.      end;
  140. {$IFDEF DEBUG}
  141.   if (C < $20) or (C > $7E) then
  142.     begin
  143.       write('[$');
  144.       WriteHexByte(C);
  145.       write(']');
  146.     end
  147.   else write( chr(C) );
  148. {$ENDIF}
  149. end;
  150.  
  151. (*** Receive character from serial line ***)
  152.  
  153. Function GetChar(Port:Integer; Timeout:Integer):Integer;
  154. var
  155.   Code:Integer;
  156. begin
  157.   Code := SioGetc(Port,Timeout);
  158.   if Code < -1 then
  159.     begin
  160.       writeln('COM',1+Port,' error');
  161.       Code := SioError(Code);
  162.       Halt;
  163.     end;
  164. {$IFDEF DEBUG}
  165.   if (Code < $20) or (Code > $7E) then
  166.     begin
  167.       write('($');
  168.       WriteHexByte(Code);
  169.       write(')');
  170.     end
  171.   else write( chr(Code) );
  172. {$ENDIF}
  173.   GetChar := Code;
  174. end;
  175.  
  176. (*** Say error code ***)
  177.  
  178. procedure SayError(Code:Integer;Message:String40);
  179. var
  180.    RetCode:Integer;
  181. begin
  182.    writeln(Message);
  183.    if Code < 0 then RetCode := SioError( Code )
  184.    else if (Code and (FramingError or ParityError or OverrunError)) <> 0 then
  185.       begin (* Port Error *)
  186.          if (Code and FramingError) <> 0 then writeln('Framing Error');
  187.          if (Code and ParityError)  <> 0 then writeln('Parity Error');
  188.          if (Code and OverrunError) <> 0 then writeln('Overrun Error')
  189.       end
  190. end;
  191.  
  192. (*** Transmits CAN's ***)
  193.  
  194. Procedure TxCAN(Port:Integer);
  195. const
  196.   CAN = $18;
  197. var
  198.   I : Integer;
  199.   Code : Integer;
  200. begin
  201.   for I:=1 to 6 do Code := SioPutc(Port,chr(CAN));
  202. end;
  203.  
  204.  
  205. end.